perm filename EXPAND.SG[DEN,LMM] blob
sn#070815 filedate 1973-11-02 generic text, type T, neo UTF8
(FILECREATED " 2-NOV-73 4:04:38" S-EXPAND)
(LISPXPRINT (QUOTE EXPANDVARS)
T)
(RPAQQ EXPANDVARS
((* These functions deal with the interactive editor package)
(FNS START RESTART RP GENAPPLY FIXFN UNFIXFN ISFORM
GENEXPANSION MAKELIST GETVAL MAKEMAKEFORM TURNON TURNOFF
NOFORMIN STRUCINCL STRUCINLIST WHERE STATE ORR
STRUCLIST? GETFILENAM)
(RECORDS STRUCLIST)
(VARS (FIXEDFNLIST))
(USERMACROS UPFORM EXPAND !EXPAND ISFORM NEXTFORM NEXFORM
GROUP !!EXPAND FORMNOFORM Q SLEVEL @ # ARGS ≠ D
SWHICH FN W DO WW COMMANDS SAVERESULT U)))
(* These functions deal with the interactive editor package)
(DEFINEQ
(START
[LAMBDA (FUNCTIONNAME)
(OR FUNCTIONNAME (SETQQ FUNCTIONNAME MOLECULES))
(TURNOFF FUNCTIONNAME)
(EDITL (LIST (SETQ SAVEDRESULTS (FOR X IN (ARGLIST FUNCTIONNAME)
COLLECT
FIRST (LIST (QUOTE STRUCFORM)
FUNCTIONNAME)
(RP X)))
(SETQ SAVEDRESULTS (LIST SAVEDRESULTS)))
NIL
(QUOTE SAVEDRESULTS)
(PACK (LIST FUNCTIONNAME ":")))
(QUOTE SAVEDRESULTS])
(RESTART
[LAMBDA NIL
(EDITL (LIST SAVEDRESULTS)
NIL
(QUOTE SAVEDRESULTS)
(QUOTE restart:))
(QUOTE SAVEDRESULTS])
(RP
[LAMBDA (STR)
(PRIN1 STR T)
(PRIN1 " ? " T)
(READ T])
(GENAPPLY
[LAMBDA (FORM GOLIST MUSTCHANGEFLG)
(PROG (ALIST (NEWFORM (fetch FORM of FORM)))
[SETQ ALIST (for V in (CONS (CAR NEWFORM)
GOLIST)
collect (LIST (GETP V (QUOTE EXPANDFLAG]
[SETQ NEWFORM (CONS (CAR NEWFORM)
(collect (KWOTE X) for X
in (CDR NEWFORM]
LP (SETQ NEWFORM (SELECTQ (GETVAL (CAR NEWFORM))
(STRUC (EVALA NEWFORM ALIST))
(LSTRUC (MAKELIST (EVALA NEWFORM ALIST)
))
(HELP)))
(AND MUSTCHANGEFLG (EQUAL NEWFORM FORM)
(PRIN1 "nothing done.
" T)
(ERROR!))
(RETURN NEWFORM])
(FIXFN
[LAMBDA (FN VALTYPE STRUCCHECK CONDITIONS)
(COND
((NOT (GETD FN))
(ERROR FN "NOT A FUNCTION")))
(PROG ((VALTYPE (GETVAL FN VALTYPE))
[FNFLAG (OR (GETP FN (QUOTE EXPANDFLAG))
(/PUT FN (QUOTE EXPANDFLAG)
(PACK (LIST FN (GENSYM]
(FIXED (GETP FN (QUOTE FIXED)))
CHECKVAR CONDITION (WT (TIMES 2 DWIMWAIT)))
(COND
(FIXED (PRIN1 FN T)
(PRIN1 " already fixed.
edit instead:" T)
(PRINT FIXED T)
(EDITE FIXED)
(RETURN FN)))
(SET FNFLAG T)
(SETQ FIXED (LIST FNFLAG))
[COND
([NUMBERP
(SETQ CHECKVAR
(OR
STRUCCHECK
(PROGN
(PRIN1 FN T)
(PRIN1 " check for STRUCFORM in " T)
(PRIN1 (ARGLIST FN)
T)
(PRIN1 "?" T)
(APPLY (QUOTE Y/N)
(LIST (CONS (QUOTE (N . o))
(FOR Z IN (ARGLIST FN)
AS I
FROM 1
COLLECT
(CONS I (CONCAT " " Z]
(SETQ FIXED (CONS (LIST (QUOTE STRUCFORM?)
(CAR (NTH (ARGLIST FN)
CHECKVAR)))
FIXED]
[COND
[CONDITIONS (SETQ FIXED (REMOVE NIL (APPEND CONDITIONS
FIXED]
(T (PROG NIL
(PRIN1 "add extra condition?" T)
WTLP(COND
((MINUSP (SETQ WT (SUB1 WT)))
(PRIN1 "...NIL
")
(RETURN NIL))
((READP T))
(T (DISMISS 500)
(GO WTLP)))
LP (COND
((SETQ CONDITION (READ T))
(SETQ FIXED (CONS CONDITION FIXED))
(PRIN1 "condition? " T)
(GO LP]
NOEXTRA
[/PUT
FN
(QUOTE FIXED)
(SETQ FIXED
(LIST (QUOTE COND)
(LIST (COND
((CDR FIXED)
(CONS (QUOTE OR)
FIXED))
(T (CAR FIXED)))
(LIST (QUOTE RETURN)
(SELECTQ VALTYPE
(LSTRUC (LIST (QUOTE LIST)
(MAKEMAKEFORM
FN)))
(MAKEMAKEFORM FN]
(ADVISE FN (QUOTE BEFORE)
FIXED)
(SETQ FIXEDFNLIST (CONS FN FIXEDFNLIST)))
FN])
(UNFIXFN
[LAMBDA (FN)
(/RPLACD (GETP FN (QUOTE FIXED)))
(/REMPROP FN (QUOTE VALTYPE))
(/REMPROP FN (QUOTE EXPANDFLAG])
(ISFORM
[LAMBDA (AT)
(STRUCFORM? AT])
(GENEXPANSION
[LAMBDA (FORM 0FORM UPFORM)
(COND
[(NUMBERP (CDR 0FORM))
(MAKELIST (collect (LSUBST (CLCREATE L)
0FORM UPFORM)
for L
in (GROUPRADS (LIST (CONS (CDDR FORM)
(CDR 0FORM]
((STRUCLIST? UPFORM)
(LSUBST (FETCH LISTITEMS OF FORM)
FORM UPFORM))
(T (MAKELIST (collect (SUBST L FORM UPFORM) for L
in (CDDR FORM])
(MAKELIST
[LAMBDA (MAKELISTVAR)
([LAMBDA (L)
(COND
((CDR L)
(CREATE STRUCLIST LISTITEMS← L))
(T (CAR L]
(MAPCONC MAKELISTVAR (FUNCTION (LAMBDA (Y)
(COND
((STRUCLIST? Y)
(APPEND (FETCH LISTITEMS OF Y)))
(T (LIST Y])
(GETVAL
[LAMBDA (FN VALTYPE)
(OR (AND (NOT VALTYPE)
(GETP FN (QUOTE VALTYPE)))
(/PUT FN (QUOTE VALTYPE)
(SELECTQ [OR VALTYPE
(PROGN (PRIN1 FN T)
(PRIN1 " value type (list/single)?" T)
(Y/N ((L . ist)
(S . ingle]
(L (QUOTE LSTRUC))
(QUOTE STRUC])
(MAKEMAKEFORM
[LAMBDA (FN)
(CONS (QUOTE LIST)
(CONS (QUOTE (QUOTE STRUCFORM))
(CONS (KWOTE FN)
(ARGLIST FN])
(TURNON
[LAMBDA (FN)
(COND
((NOT FN)
(SETQ FN FIXEDFNLIST)))
(COND
((ATOM FN)
(COND
((NOT (GETP FN (QUOTE FIXED)))
(FIXFN FN)))
(/SET (GETP FN (QUOTE EXPANDFLAG)))
FN)
(T (MAPCAR FN (FUNCTION TURNON])
(TURNOFF
[LAMBDA (FN)
(COND
((NOT FN)
(SETQ FN FIXEDFNLIST)))
(COND
((ATOM FN)
(COND
((NOT (GETP FN (QUOTE FIXED)))
(FIXFN FN)))
(/SET (GETP FN (QUOTE EXPANDFLAG))
T)
FN)
(T (MAPCAR FN (FUNCTION TURNOFF])
(NOFORMIN
[LAMBDA (X)
(OR (NLISTP X)
(AND (NOT (STRUCFORM? X))
(EVERY (CDR X)
(FUNCTION NOFORMIN])
(STRUCINCL
[LAMBDA (CL)
(SOME CL (FUNCTION (LAMBDA (X)
(STRUCFORM? (CAR X])
(STRUCINLIST
[LAMBDA (LIST)
(SOME LIST (FUNCTION (LAMBDA (ITEM)
(STRUCFORM? ITEM])
(WHERE
[LAMBDA (EXPRESSION)
(PRIN1 "Level " T)
(PRIN1 LEVEL T)
(COND
((LISTP WHICH)
(PRIN1 (COND
((EQ (SUB1 LEVEL)
(CDR WHICH))
", #")
(T " within #"))
T)
(PRIN1 (CAR WHICH)
T)
(PRIN1 " at level " T)
(PRIN1 (CDR WHICH)
T)))
(PRIN1 ", " T)
(PROG ((EXPLAININDENT))
(EXPLAIN EXPRESSION)
(TERPRI T])
(STATE
[LAMBDA (FN)
(COND
((NULL FN)
(SETQ FN FIXEDFNLIST)))
(COND
[(LISTP FN)
(MAPC FN (FUNCTION (LAMBDA (X)
(MAPRINT (STATE X)
T NIL ".
" NIL NIL T]
(T (CONS FN (CONS (QUOTE is)
(COND
[(SETQ FN (GETP FN (QUOTE EXPANDFLAG)))
(SELECTQ (EVALV FN)
(T (QUOTE (off)))
(NIL (QUOTE (on)))
(QUOTE (in some wierd state]
(T (QUOTE (not fixed])
(ORR
[NLAMBDA X
(EVAL (LIST (QUOTE PROG)
(QUOTE ((HELPFLAG)))
(LIST (QUOTE RETURN)
(LIST (QUOTE CAR)
(CONS (QUOTE OR)
(MAPCAR X (FUNCTION (LAMBDA (Z)
(LIST (QUOTE NLSETQ)
Z])
(STRUCLIST?
[LAMBDA (X)
(AND (STRUCFORM? X)
(EQ (FETCH LISTID OF X)
(QUOTE LIST])
(GETFILENAM
[LAMBDA (IO)
(SELECTQ IO
[(I INPUT)
(INFILEP (PROGN (PRIN1 "INPUT FILE? " T)
(READ T]
(OUTFILEP (PROGN (PRIN1 "OUTPUT FILE? " T)
(READ T])
)
(RECORD STRUCLIST (SFID LISTID . LISTITEMS) DEFAULT SFID← (QUOTE
STRUCFORM) LISTID← (QUOTE LIST))
(RPAQ FIXEDFNLIST)
(ADDTOVAR
USERMACROS
(U NIL UPFORM)
[W NIL (IF (STRUCFORM? (##))
((BIND (E (SETQ #1 (GETFILENAM (QUOTE OUTPUT)))
T)
(E (WRITEFILE (LIST (##))
#1))
(S #2)
UP MARK ↑
(E (DSUBST (≠QUOTE (STRUCFORM READFILE ≠ #1))
#2
(##))
T)
←← 1]
(DO NIL UP MARK 1 (LCL !!EXPAND)
←← 1 (IF [AND (NOT (STRUCLIST? (##))
(STRUCFORM? (##]
(!EXPAND)
(NIL))
@)
(WW NIL MARK (LPQ UPFORM)
(IF (STRUCLIST? (##))
(W)
((MBD STRUCFORM LIST)
W))
←←)
[COMMANDS NIL (E (MAPCAR USERMACROS (FUNCTION CAR]
(SAVERESULT NIL (E (SETQ RESULT (##))
T)
(E (QUOTE RESULT-SAVED)))
(UPFORM NIL 0 (← STRUCFORM))
[EXPAND NIL
(ORR [(IF (STRUCLIST? (##))
((BIND (E (SETQ #1 (GENEXPANSION (##)
(## !0)
(## UPFORM)))
T)
UPFORM
(BI 1 -1)
(I 1 #1)
(BO 1)))
((IF (STRUCFORM? (##))
(UP (I 1 (GENAPPLY (## 1)
NIL T))
1]
((E (QUOTE can't]
[!EXPAND
NIL
(ORR
[(IF (STRUCLIST? (##))
((BIND (E (SETQ #1 (GENEXPANSION (##)
(## !0)
(## UPFORM)))
T)
UPFORM
(BI 1 -1)
(I 1 #1)
(BO 1)))
((IF (STRUCFORM? (##))
(UP MARK ↑ (I E (PROG1 NIL
(/DSUBST (GENAPPLY
(## ← 1)
FIXEDFNLIST)
(## ← 1)
(##)))
T)
←← 1]
((E (QUOTE CAN'T]
[ISFORM NIL (IF (STRUCFORM (##]
(NEXTFORM NIL (ORR (F STRUCFORM)
(UPFORM)))
(NEXFORM NIL (ORR (ISFORM)
(NEXTFORM)))
[GROUP (X Y)
(COMS (SUBPAIR (QUOTE (Z W))
(LIST (IPLUS X 2)
(IPLUS Y 2))
(QUOTE (EMBED (Z THRU W)
IN STRUCFORM LIST]
(!!EXPAND NIL (LCL (LPQ ↑ FORMNOFORM !EXPAND)))
[FORMNOFORM NIL (LC STRUCFORM (IF (NOFORMIN (CDR (##]
(Q NIL (MBD QUOTE))
(SLEVEL NIL MARK (E (SETQ LEVEL 0)
T)
(LPQ UPFORM (E (SETQ LEVEL (ADD1 LEVEL))
T))
←←)
(@ NIL UP 1 SWHICH SLEVEL (E (WHERE (##))
T))
[# (X)
(IF (NUMBERP (QUOTE X))
[(IF (STRUCLIST? (##))
((COMS (IPLUS X 2)))
((LCL (I F (QUOTE ((*ANY* STRUCTURE STRUCFORM)
--))
(ADD1 X]
(E (QUOTE ?]
[ARGS NIL (E (CDR (##]
(≠ NIL FORMNOFORM)
(D NIL (LCL NEXTFORM))
(SWHICH NIL MARK (ORR ((E (SETQ WHICH)
T)
[LC UP (E (SETQ WHICH (LENGTH (##)))
T)
0
(IF (STRUCLIST? (##))
(NIL)
((E (ERROR!)
T]
(E (SETQ WHICH (IPLUS -1 (LENGTH (##))
(IMINUS WHICH)))
T)
(E (PROG (LEVEL)
(## SLEVEL)
(SETQ WHICH (CONS WHICH LEVEL)))
T))
(NIL))
←←)
(FN (X)
F
(STRUCFORM X --)))
(ADDTOVAR EDITCOMSA SWHICH D ≠ ARGS @ SLEVEL Q FORMNOFORM !!EXPAND
NEXFORM NEXTFORM ISFORM !EXPAND EXPAND UPFORM SAVERESULT
COMMANDS WW DO W U)
(ADDTOVAR EDITCOMSL FN # GROUP)
STOP